Shareware Grab Bag/Shareware Grab Bag.iso/095/tbbs105.arc/FILESYS.INC

Text File | 1985-10-02 | 20.5 KB | 735 lines

procedure filesys;

  const
    mostfiles = 40;
    soh = 1;
    eot = 4;
    ack = 6;
    nak = $15;
    can = $18;
    C = $43;
    drivecap = 191; {Kbyte capacity of files drive}
    ksize = 1; {minimum increment of file size in Kbytes}

  type
    filerec = record
               title: name;
               submit: integer;
               date: name;
               size: integer;
               accesses: integer;
               ASCII: boolean;
               section: byte;
               public: boolean;
             end;
    channel = array[0..127] of byte;

  var
    filefile: file of filerec;
    filetab: array[0..mostfiles] of filerec;
    filebuff: array [0..16] of channel;
    datafile: file;
    chksum: byte;
    CRC: integer;
    crcmode: boolean;
    enddir: integer;
    comch: char;

  procedure xmit(x:byte);

    begin
      xmitchar(chr(x));
    end;

  function inbyte: byte;

    var temp: char;

    begin
      repeat until inready or not cts;
      if keypressed then read(kbd, temp) else temp := recvchar;
      inbyte := ord(temp);
    end;

  procedure calcCRC(data:byte);

    var
      carry: boolean;
      i: byte;

    begin
      chksum := lo(chksum + data);
      for i := 0 to 7 do begin
        carry := (crc and $8000) <> 0;
        crc := crc shl 1;
        if (data and $80) <> 0 then crc := crc or $0001;
        if carry then crc := crc xor $1021;
        data := lo(data shl 1);
      end;
    end;

  procedure sendcalc(ch : byte);

    begin
      xmit(ch);
      calcCRC(ch);
    end;

  procedure acknak(var inch: byte; time: integer);

    var loop, loopend: integer;

    begin
      loopend := 100 * time;
      loop := 0;
      inch := 0;
      repeat
        delay(10);
        if inready then inch := inbyte;
        loop :=loop + 1;
      until (inch in [ack, nak, can, C]) or (loop >= loopend) or not cts;
    end;

  function acknakout(ch : byte): boolean;

    var  times, loops: integer;

    begin
      times := 0;
      repeat
        loops := 0;
        xmit(ch);
        while (loops < 10) and not timedin do loops := loops + 1;
        times := times + 1;
      until inready or (times > 9) or not cts;
      acknakout := inready and cts;
    end;

  procedure download(var successful: boolean);

    var
      inch, loop: byte;
      blocknum, period, tries: integer;
      done: boolean;
      temp: line;

    begin
      reset(datafile);
      str(filesize(datafile):4, temp);
      lineout('Ready for XMODEM transfer:');
      lineout('File open:' + temp + ' records;');
      lineout('To cancel: type CTL-X until you return to command prompt.');
      blockread(datafile, filebuff[0], 1);
      done := false;
      tries := 0;
      blocknum := 1;
      crcmode := false;
      repeat
        acknak(inch, 60);
        if inch = 0 then inch := can;
        if inch = C then begin
          crcmode := true;
          writeln('CRC mode requested');
        end;
        if inch = ack then begin
          if eof(datafile) then done := true else begin
            write(cr + 'Sent #', blocknum:4);
            blockread(datafile, filebuff[0], 1);
            blocknum := blocknum + 1;
            tries := 0;
          end;
        end
        else tries := tries + 1;
        if (inch <> can) and cts and not done then begin
          xmit(soh);
          xmit(lo(blocknum));
          xmit(255-lo(blocknum));
          chksum := 0;
          crc := 0;
          for loop := 0 to 127 do sendcalc(filebuff[0][loop]);
          calcCRC(0);
          calcCRC(0);
          if crcmode then begin xmit(hi(crc)); xmit(lo(crc)); end
            else xmit(chksum);
        end;
        if tries = 5 then crcmode := not crcmode;
      until (inch = can) or done or (tries= 10) or not cts;
      successful := done;
      tries := 0;
      if successful and cts then repeat
        xmit(eot);
        acknak(inch, 10);
        tries := tries + 1;
      until (inch=ack) or (tries > 10) or not cts;
      if cts and (inch <> can) and not successful then xmit(can);
      close(datafile);
    end;

  function recchar(var error: boolean): byte;

    var temp: byte;

    begin
      temp := 0;
      if not cts then error := true;
      if not error then begin
        if not timedin then error := true
        else begin
          temp := inbyte;
          calcCRC(temp);
          recchar := temp;
        end;
      end;
    end;

  procedure clearline;

    var junk: byte;

    begin
      while timedin do junk := inbyte;
    end;

{$I-}
  procedure upload(var successful: boolean);

    var
      blocknum, tries, byteloc : integer;
      comp, locblock, crc2     : integer;
      fatal, error, done       : boolean;
      opening, inch, locrc     : byte;
      hicrc, csum2, mode       : byte;

    begin
      lineout('Beginning XMODEM protocol upload:');
      lineout('To cancel: type CTRL-X until you return to command prompt.');
      tries := 0;
      done := false;
      opening := 0;
      locblock := 1;
      rewrite(datafile);
      fatal := ioresult > 0;
      if crcmode then mode := C else mode := nak;
      if cts and not fatal then fatal := not acknakout(mode);
      while cts and not (done or fatal) do begin
        tries := tries + 1;
        error := false;
        opening := recchar(error);
        if opening = can then fatal := true;
        if opening = eot then done := true;
        if (opening <> eot) and (opening <> soh) and not fatal
          then error := true;
        if cts and not (error or fatal or done) then begin
          blocknum := recchar(error);
          comp := recchar(error);
          if lo(comp + blocknum + opening) <> 0 then error := true;
          byteloc := 0;
          crc := 0;
          chksum := 0;
          while (byteloc < 128) and not (error or fatal) do begin
            filebuff[0][byteloc] := recchar(error);
            byteloc := byteloc + 1;
          end;
          if cts and not (error or fatal) then begin
            calcCRC(0);
            calcCRC(0);
            crc2 := crc;
            csum2 := chksum;
            hicrc := recchar(error);
            if crcmode then begin
              locrc := recchar(error);
              if (lo(crc2) <> locrc) or (hi(crc2) <> hicrc) then error := true;
            end else if csum2 <> hicrc then error := true;
            if (lo(locblock) <> blocknum)
              and (lo(locblock) <> lo(blocknum+1))
              and not error
              then fatal := true;
            if (lo(locblock) = blocknum) and not (error or fatal) then begin
              blockwrite(datafile, filebuff[0], 1);
              write(cr + ' Received #', blocknum:4);
              if IOresult <> 0 then fatal := true;
              tries := 0;
              locblock := locblock + 1;
            end;
          end;
        end;
        if not (fatal or error) then flush else clearline;
        if done or not (error or fatal) then fatal := not acknakout(ack);
        if error and not fatal then begin
          fatal := not acknakout(nak);
          if tries > 6 then crcmode := not crcmode;
        end;
      end;
      if fatal then xmit(can);
      if done then xmit(ack);
      close(datafile);
      successful := (IOresult = 0) and done and not fatal;
      if not successful then erase(datafile);
    end;

  procedure storebuff(var buffernum: byte; var paused, aborted: boolean);

    var loop: byte;

    begin
      loop := 0;
      while (loop < buffernum) and not aborted do begin
        blockwrite(datafile, filebuff[loop], 1);
        if IOresult > 0 then aborted := true;
        loop := loop + 1;
      end;
      if buffernum in [1..16] then filebuff[0] := filebuff[buffernum];
      buffernum := 0;
      repeat xmit(17) until timedin;
      paused := false;
    end;

  procedure textcap(var successful: boolean);

    var
      buffernum, where, loop  : byte;
      cc, cz, paused          : boolean;
      withecho, done, aborted : boolean;
      temp                    : byte;

    begin
      withecho := (getcap('Do you want your text echoed (Y/N) ? ') = 'Y');
      lineout('Beginning text capture: two CTRL-Cs abort, two CTRL-Zs end.');
      cc := false;
      cz := false;
      done := false;
      paused := false;
      buffernum := 0;
      where := 0;
      rewrite(datafile);
      aborted := (IOresult > 0);
      while cts and not (done or aborted) do begin
        if paused then
          if not timedin then storebuff(buffernum, paused, aborted);
        temp := inbyte;
        if not cts then aborted := true;
        if withecho and outready then xmit(temp);
        if temp = 3 then begin if cc then aborted := true else cc := true; end
          else cc := false;
        if temp = 26 then begin if cz then done := true else cz := true; end
          else cz := false;
        filebuff[buffernum][where] := temp;
        where := where + 1;
        if where > 127 then begin
          where := 0;
          buffernum := buffernum + 1;
        end;
        if buffernum > 14 then begin
          xmit(19);
          paused := true;
        end;
        if buffernum > 16 then aborted := true;
      end;
      if done and cts and not aborted then begin
        buffernum := buffernum + 1;
        storebuff(buffernum, paused, aborted);
      end;
      close(datafile);
      if aborted and (IOresult = 0) then erase(datafile);
    successful := done and (IOresult=0) and not aborted;
    end;
{$I+}

  function exists(filename: name): boolean;

    var found: boolean;

    begin
      assign(datafile, filename);
      {$I-} reset(datafile) {$I+};
      found := (IOresult = 0);
      if found then close(datafile);
      exists := found;
    end;

  function alpha(filename: name): boolean;

    var strpos: integer;
        okay:   boolean;
        dots:   byte;

    begin
      dots := 0;
      alpha := true;
      if length(filename) > 0 then
        for strpos := 1 to length(filename) do begin
          if filename[strpos] = '.' then dots := dots + 1;
          if not (filename[strpos] in ['.', '-', '_', '0'..'9', 'A'..'Z'])
            then alpha := false;
        end;
      if dots > 1 then alpha := false;
    end;

  function getlegal: name;

    var filename:  name;
        dotpos: integer;

    begin
      repeat
        filename := allcaps(getinput('Enter name of file ? ', 12, echo));
        dotpos := pos('.', filename);
      until ((dotpos < 10) and (dotpos <> 1)
       and (not((dotpos = 0) and (length(filename) > 8)))
       and (not((dotpos > 0) and (length(filename) > dotpos + 3)))
       and alpha(filename))
       or (filename = '');
      getlegal := filename;
    end;

  function dirpos(filename: name): integer;

    var loopvar: integer;

    begin
      dirpos := 0;
      loopvar := 0;
      repeat
        loopvar := loopvar + 1;
      until (filetab[loopvar].title = filename) or (loopvar >= enddir);
    if filetab[loopvar].title = filename then dirpos := loopvar;
    end;

  function getsect: byte;

    var temp: integer;

    begin
      if sectsin then repeat
        temp := getint(numsects, 0, 'Which section (0 for all, ? for list) ? ');
        if temp = -1 then listsections else getsect := temp;
      until (temp <> -1) or not cts
      else getsect := 1;
    end;

  procedure addfile(filename: name; sectnum: byte; xmodem: boolean);

    begin
      with filetab[enddir + 1] do begin
        title := filename;
        submit := usernum;
        if clockin then date := timeon;
        assign(datafile, filedrive + filename);
        reset(datafile);
        size := filesize(datafile);
        close(datafile);
        accesses := 0;
        ASCII := not xmodem;
        section := sectnum;
        public := false;
      end;
    end;

  procedure newfile(xmodem: boolean);

    var
      filename: name;
      successful: boolean;
      sectnum: byte;

    begin
      clearsc;
      if enddir >= mostfiles then lineout('No file space available.')
      else begin
        stringout('Upload: ');
        filename := getlegal;
        if filename <> '' then begin
          if exists(filedrive + filename) then lineout('File name in use.')
          else begin
            repeat sectnum := getsect until (sectnum <> 0) or not cts;
            assign(datafile, filedrive + filename);
            if cts then begin
              if xmodem then upload(successful)
                else textcap(successful);
              if successful then addfile(filename, sectnum, xmodem);
              clearline;
              if successful then enddir := enddir + 1
                else lineout('Fatal transfer error or disk full...');
            end;
          end;
        end;
      end;
    end;

  function legaltab(prompt: line): integer;

    var filename: name;
        tabloc:   integer;

    begin
      tabloc := 0;
      clearsc;
      stringout(prompt);
      filename := getlegal;
      if filename <> '' then begin
        tabloc := dirpos(filename);
        if tabloc <> 0 then
          if not (filetab[tabloc].public or (access > reg)) then tabloc := 0;
        if tabloc <> 0 then assign(datafile, filedrive + filename)
          else if filename <> '' then lineout('No such file available.');
      end;
      legaltab := tabloc;
    end;

  procedure transmitfile;

    var
      successful: boolean;
      tabloc: integer;

    begin
      tabloc := legaltab('Download: ');
      if tabloc > 0 then begin
        download(successful);
        if successful then with filetab[tabloc] do
          accesses := accesses + 1
        else lineout('Transfer failed.');
      end;
    end;

  procedure textdump;

    var
      tabloc : integer;
      libname: longname;

    begin
      tabloc := legaltab('ASCII text dump: ');
      lineout(space);
      if tabloc > 0 then with filetab[tabloc] do begin
        libname := title;
        if pos('.LBR',title) > 1 then begin
          lineout(title + ' is a library file: please select a member: ');
          libname := getlegal;
          if libname = '' then libname := 'DIR';
          libname := copy(title, 1, length(title)-4) + '/' + libname;
        end;
        typefile(filedrive + libname, false);
        if not cancelled then accesses := accesses + 1;
      end;
    end;

  procedure showspace;

    var  loop, howbig, howmuch, sectmin : integer;
         temp : line;

    begin
      sectmin := ksize shl 3;
      howmuch := drivecap;
      if enddir > 0 then for loop := 1 to enddir do
       with filetab[loop] do begin
        howbig := (size + sectmin - 1) div sectmin;
        howmuch := howmuch - howbig;
      end;
      str(howmuch:4, temp);
      if cts then lineout(cr + lf + temp + 'K space remaining.');
    end;

  procedure dir(sectnum: byte);

    var loop, spaces : byte;
        howbig, sectmin : integer;
        any  : boolean;
        temp : line;

    begin
      any := false;
      sectmin := ksize shl 3;
      lineout(space);
      if sectsin then lineout('Section ' + sect[sectnum] + ':');
      if enddir > 0 then for loop := 1 to enddir do with filetab[loop] do begin
        howbig := (size + sectmin - 1) div sectmin;
        if cts and (public or (access = sysop) or (submit = usernum))
         and (sectnum = section) then begin
          str(howbig:4, temp);
          for spaces := length(title) to 13 do temp := ' ' + temp;
          stringout(title + temp + 'K');
          if clockin then stringout('   ' + date);
          if not public then stringout('  * Private *');
          lineout(space);
          if (access = sysop) or (submit = usernum) then begin
            str(accesses:4, temp);
            lineout('Accesses: ' + temp + '    From: ' + getname(submit));
          end;
          any := true;
        end;
      end;
      if cts and not any then lineout('No files found.');
    end;

  procedure directory;

    var sectnum : byte;

    begin
      stringout('Directory: ');
      sectnum := getsect;
      if sectnum > 0 then dir(sectnum)
        else for sectnum := 1 to numsects do dir(sectnum);
      showspace;
    end;

  procedure ldir;

    var
      tabloc : integer;

    begin
      tabloc := legaltab('Library directory: ');
      lineout(space);
      if tabloc > 0 then typefile(filedrive + filetab[tabloc].title + '/DIR', false);
    end;

  procedure killfile;

    var loop, tabloc: integer;

    begin
      tabloc := legaltab('Delete: ');
      if tabloc > 0 then begin
        erase(datafile);
        if enddir > tabloc then for loop := tabloc + 1 to enddir do
          filetab[loop - 1] := filetab[loop];
        enddir := enddir - 1;
      end;
    end;

  procedure installfile;

    var filename : name;
        sectnum  : byte;

    begin
      if enddir < mostfiles then begin
        filename := getlegal;
        if filename <> '' then begin
          if exists(filedrive+filename) and (dirpos(filename) = 0) then begin
            repeat sectnum := getsect until (sectnum <> 0) or not cts;
            addfile(filename, sectnum, true);
            enddir := enddir + 1;
            lineout('File installed.');
          end;
        end;
      end;
    end;

  function newname(tabloc: integer): name;

    var filename: name;

    begin
      newname := filetab[tabloc].title;
      stringout('New name? ');
      filename := getlegal;
      if (filename <> '') then begin
        if not exists(filedrive + filename) then begin
          assign(datafile, filedrive + filetab[tabloc].title);
          rename(datafile, filename);
          newname := filename;
          stringout('File renamed.');
        end
        else lineout('Name in use - cannot rename.');
      end;
    end;


  procedure editheader;

    var tabloc: integer;
        filename: name;
        innum: integer;
        sectstring: name;

    begin
      tabloc := legaltab('Edit: ');
      if tabloc > 0 then with filetab[tabloc] do begin
        repeat
          str(section:3, sectstring);
          lineout(space);
          lineout('1- Name    : ' + title);
          lineout('2- From    : ' + getname(submit));
          lineout('3- Section : ' + sectstring);
          lineout('4- Public? : ' + yn[public]);
          lineout(space);
          innum := getint(4, 0, 'Number of parameter to change? ');
          case innum of
            1: title := newname(tabloc);
            2: submit := getid('Name of submitter? ');
            3: repeat section := getsect until (section <> 0) or not cts;
            4: public := not public;
          end;
        until (innum = 0) or not cts;
        assign(datafile, filedrive + title);
        reset(datafile);
        size := filesize(datafile);
        close(datafile);
      end else lineout('File not in directory.');
    end;

  procedure initfile;

    var
      loopvar: integer;
      temp: name;

    begin
      lineout('Initializing file system...');
      loopvar := 0;
      assign(filefile, 'FILES.BBS');
      {$I-} reset(filefile) {$I+};
      if IOresult = 0 then begin
        while not eof(filefile) do begin
          loopvar := loopvar + 1;
          read(filefile, filetab[loopvar]);
        end;
        close(filefile);
      end;
      enddir := loopvar;
      filesopen := true;
    end;

  procedure closefile;

    var loopvar: integer;

    begin
      rewrite(filefile);
      if enddir > 0 then
        for loopvar := 1 to enddir do write(filefile, filetab[loopvar]);
      close(filefile);
      filesopen := false;
    end;

  begin
    clearsc;
    initfile;
    if not expert then outfile(filemenu);
    repeat
      lineout(space);
      comch := getcap('Files command (or ? for menu) ? ');
      case comch of
       'D' : directory;
       'S' : transmitfile;
       'T' : textdump;
       'H' : outfile(filehelp);
       'G' : disconnect;
       '?' : outfile(filemenu);
       'L' : ldir;
       'U' : if access>newuser then begin crcmode := true; newfile(true); end;
       'C' : if access>newuser then begin crcmode := false; newfile(true); end;
       'V' : if access>newuser then newfile(false);
       'K' : if access = sysop then killfile;
       'I' : if access = sysop then installfile;
       'E' : if access = sysop then editheader;
      end;
    until (comch = 'Q') or not cts;
    if cts then lineout('Closing file system...');
    closefile;
  end;